(DEFPROP CYCOMAFNS
(CYCOMAFNS MAXLIST TWICE CARLIST CDRLIST LCARLIST LCDRLIST
DIFF PLUSLIST LMASSOC NUMPARTITIONS CLPARTITIONS
CLPARTS CL=PARTS CLDIFF CLCOUNT CLPARTITIONSN
CLCREATE CLINSERT CLEXPAND GENRAD GENRADS
GENRADLIST GENRADLIST1 GROUPRADS GROUPRADS1
VALENCE GENMOL NUMPARTITIONS* GROUPBY
FVPARTITION1 FVPART1 MINLOOPS MAXLOOPS)
VALUE)
(DEFPROP MAXLIST (LAMBDA (L)
(FOR NEW X IN L MAX X))
EXPR)
(DEFPROP TWICE (LAMBDA (X)
(PLUS X X))
EXPR)
(DEFPROP CARLIST (LAMBDA (L)
(FOR NEW X IN L LIST (CAR X)))
EXPR)
(DEFPROP CDRLIST (LAMBDA (L)
(FOR NEW X IN L LIST (CDR X)))
EXPR)
(DEFPROP LCARLIST (LAMBDA (L)
(FOR NEW X IN L LIST (CARLIST X)))
EXPR)
(DEFPROP LCDRLIST (LAMBDA (L)
(FOR NEW X IN L LIST (CDRLIST X)))
EXPR)
(DEFPROP DIFF (LAMBDA (L1 L2)
(FOR NEW X IN L1 WHEN (NOT (MEMBER X L2))
XLIST X))
EXPR)
(DEFPROP PLUSLIST (LAMBDA (L)
(FOR NEW X IN L PLUS X))
EXPR)
(DEFPROP LMASSOC
(LAMBDA
(X Y VAL)
(PROG2 (FOR NEW PR IN Y DO
(IF (EQUAL (CAR PR)
X)
THEN
(RETURN (SETQ VAL (CDR PR)))))
VAL))
EXPR)
(DEFPROP
NUMPARTITIONS
(LAMBDA
(N NUMPARTS MINPART MAXPART)
(IF (EQUAL NUMPARTS 1.0)
THEN
(IF (OR (GREATERP MINPART N)
(LESSP MAXPART N))
THEN NIL ELSE (LIST (LIST N)))
ELSE
(FOR NEW I := ((MAX MINPART (DIFFERENCE N
(TIMES (SUB1 NUMPARTS)
MAXPART)))
(MIN MAXPART (QUOTIENT N NUMPARTS)))
FOR NEW RESTPART IN (NUMPARTITIONS (DIFFERENCE N I)
(SUB1 NUMPARTS)
I MAXPART)
LIST
(CONS I RESTPART))))
EXPR)
(DEFPROP
CLPARTITIONS
(LAMBDA
(CL PARTSIZES)
(IF (NULL PARTSIZES)
THEN
(LIST NIL)
ELSEIF
(NULL (CDR PARTSIZES))
THEN
(LIST (LIST CL))
ELSEIF
(ZEROP (CAR PARTSIZES))
THEN
(MAPCAR (FUNCTION (LAMBDA (X)
(CONS NIL X)))
(CLPARTITIONS CL (CDR PARTSIZES)))
ELSEIF
(EQUAL (CAR PARTSIZES)
(CADR PARTSIZES))
THEN
(PROG (N THISPART)
(SETQ N 1.0)
(SETQ THISPART (CAR PARTSIZES))
(FOR PARTSIZES ON (CDR PARTSIZES)
WHILE
(EQUAL (CAR PARTSIZES)
THISPART)
DO
(SETQ N (ADD1 N)))
(IF (NULL PARTSIZES)
THEN
(RETURN (CL=PARTS CL N THISPART)))
(RETURN (FOR NEW BIGPART IN (CLPARTS CL (TIMES N
THISPART))
AS NEW RESTPARTSLIST IS
(CLPARTITIONS (CLDIFF CL BIGPART)
PARTSIZES)
FOR NEW LITTLEPARTS IN
(CL=PARTS BIGPART N THISPART)
FOR NEW RESTPARTS IN RESTPARTSLIST XLIST
(APPEND LITTLEPARTS RESTPARTS))))
ELSE
(FOR NEW PART IN (CLPARTS CL (CAR PARTSIZES))
FOR NEW PARTS IN (CLPARTITIONS (CLDIFF CL PART)
(CDR PARTSIZES))
XLIST
(CONS PART PARTS))))
EXPR)
(DEFPROP
CLPARTS
(LAMBDA
(CL PARTSIZE)
(IF (ZEROP PARTSIZE)
THEN
(LIST NIL)
ELSEIF
(NULL (CDR CL))
THEN
(LIST (LIST (CONS (CAAR CL)
PARTSIZE)))
ELSE
(PROG (SIZE)
(SETQ SIZE (DIFFERENCE PARTSIZE (CLCOUNT (CDR CL))))
(RETURN (FOR NEW X := ((MAX SIZE 1.0)
(MIN PARTSIZE (CDAR CL)))
FOR NEW PART IN (CLPARTS (CDR CL)
(DIFFERENCE
PARTSIZE X))
XLIST FIRST
(IF (LESSP 0.0 SIZE)
THEN NIL ELSE (CLPARTS (CDR CL)
PARTSIZE))
(CONS (CONS (CAAR CL)
X)
PART))))))
EXPR)
(DEFPROP
CL=PARTS
(LAMBDA
(CL NPARTS PARTSIZE)
(IF
(NULL (CDR CL))
THEN
(SETQ CL (LIST (CONS (CAAR CL)
PARTSIZE)))
(LIST (FOR NEW I := (1.0 NPARTS)
XLIST CL))
ELSE
(FOR NEW X IN (NUMPARTITIONS (CDAR CL)
NPARTS 0.0 PARTSIZE)
FOR NEW Y IN (CLPARTITIONS (CDR CL)
(FOR NEW XX IN X LIST
(DIFFERENCE PARTSIZE XX)))
XLIST
(FOR NEW XX IN X AS NEW YY IN Y LIST
(IF (ZEROP XX)
THEN YY ELSE (CONS (CONS (CAAR CL)
XX)
YY))))))
EXPR)
(DEFPROP CLDIFF (LAMBDA
(CL1 CL2)
(IF (NULL CL2)
THEN CL1 ELSEIF (EQUAL (CAR CL1)
(CAR CL2))
THEN
(CLDIFF (CDR CL1)
(CDR CL2))
ELSEIF
(EQ (CAAR CL1)
(CAAR CL2))
THEN
(CONS (CONS (CAAR CL1)
(DIFFERENCE (CDAR CL1)
(CDAR CL2)))
(CLDIFF (CDR CL1)
(CDR CL2)))
ELSE
(CONS (CAR CL1)
(CLDIFF (CDR CL1)
CL2))))
EXPR)
(DEFPROP CLCOUNT (LAMBDA (CL)
(FOR NEW X IN CL PLUS (CDR X)))
EXPR)
(DEFPROP CLPARTITIONSN (LAMBDA (CL N MINPARTSIZE MAXPARTSIZE)
(FOR NEW PARTSIZES IN
(NUMPARTITIONS (CLCOUNT CL)
N MINPARTSIZE
MAXPARTSIZE)
NCONC FIRST NIL (CLPARTITIONS
CL PARTSIZES)))
EXPR)
(DEFPROP CLCREATE (LAMBDA (L)
(PROG (CL)
(FOR NEW X IN L DO (SETQ
CL
(CLINSERT X CL)))
(RETURN CL)))
EXPR)
(DEFPROP CLINSERT (LAMBDA
(ITEM CL)
(IF (NOT CL)
THEN
(LIST (CONS ITEM 1.0))
ELSEIF
(EQUAL ITEM (CAAR CL))
THEN
(REPLACE (CDR (CAR CL))
(ADD1 (CDR (CAR CL))))
CL ELSEIF (LEQ ITEM (CAAR CL))
THEN
(CONS (CONS ITEM 1.0)
CL)
ELSE
(REPLACE (CDR CL)
(CLINSERT ITEM (CDR CL)))))
EXPR)
(DEFPROP CLEXPAND (LAMBDA (CL)
(FOR NEW PR IN CL FOR NEW I :=
(1.0 (CDR PR))
LIST
(CAR PR)))
EXPR)
(DEFPROP
GENRAD
(LAMBDA
(CL)
(IF (AND (NULL (CDR CL))
(EQUAL (CDAR CL)
1.0))
THEN
(PERMRADS (CAAR CL)
NIL T)
ELSE
(FOR NEW OLDCL ON CL AS NEW CENTER IS (CAAR OLDCL)
AS NEW NEWCL IS (CLDIFF CL (LIST (CONS CENTER 1.0)))
FOR NEW DEGREE := (1.0 (MIN (CLCOUNT NEWCL)
(SUB1 (VALENCE CENTER))))
FOR NEW RADS IN (GENRADS NEWCL DEGREE)
NCONC FIRST NIL (PERMRADS CENTER RADS T))))
EXPR)
(DEFPROP GENRADS (LAMBDA
(CL N)
(IF (NULL CL)
THEN
(LIST NIL)
ELSE
(FOR NEW PARTITION IN (CLPARTITIONSN CL N 1.0
(CLCOUNT CL))
NCONC FIRST NIL (GENRADLIST PARTITION))))
EXPR)
(DEFPROP GENRADLIST (LAMBDA (CLLIST)
(GROUPRADS (GENRADLIST1 (CLCREATE CLLIST))
))
EXPR)
(DEFPROP GENRADLIST1 (LAMBDA (CLCL)
(FOR NEW CLNUMPAIR IN CLCL LIST
(CONS (GENRAD (CAR CLNUMPAIR))
λ (CDR CLNUMPAIR))))
EXPR)
(DEFPROP GROUPRADS (LAMBDA (RADCLIST)
(IF (NULL RADCLIST)
THEN
(LIST NIL)
ELSE
(GROUPRADS1 (CAAR RADCLIST)
(CDAR RADCLIST)
(GROUPRADS (CDR RADCLIST)))
))
EXPR)
(DEFPROP GROUPRADS1
(LAMBDA (RADLIST N RADSLIST)
(IF (ZEROP N)
THEN RADSLIST ELSE
(FOR RADLIST ON RADLIST FOR NEW RADS IN
(GROUPRADS1 RADLIST (SUB1 N)
RADSLIST)
LIST
(CONS (CAR RADLIST)
RADS))))
EXPR)
(DEFPROP VALENCE (LAMBDA (AT)
(COND ((NUMBERP AT)
AT)
((ATOM AT)
(GET AT (QUOTE VALENCE)))
(T (FREEVALENCESIZE AT))))
EXPR)
(DEFPROP GENMOL
(LAMBDA
(CL)
(PROG (MINDEG RESULT NATOMS)
(IF (EQUAL 1.0 (SETQ NATOMS (CLCOUNT CL)))
THEN
(RETURN (PERMRADS (CAAR CL)
NIL NIL))
ELSEIF
(ZEROP (REMAINDER NATOMS 2.0))
THEN
(FOR NEW PART IN (CL=PARTS CL 2.0 (QUOTIENT
NATOMS 2.0))
FOR NEW RADS IN (GENRADLIST PART)
DO
(SETQ RESULT (APPEND (PERMRADS NIL RADS NIL)
RESULT)))
(SETQ MINDEG 3.0)
ELSE
(SETQ MINDEG 2.0))
(SETQ NATOMS (SUB1 NATOMS))
(FOR NEW PAIR IN CL AS NEW CENTER IS (CAR PAIR)
AS NEW NEWCL IS (CLDIFF CL (LIST (CONS CENTER
1.0)))
FOR NEW DEG := (MINDEG (MIN (VALENCE CENTER)
NATOMS))
FOR NEW P IN (CLPARTITIONSN NEWCL DEG 1.0
(QUOTIENT NATOMS
2.0))
FOR NEW RADS IN (GENRADLIST P)
DO
(SETQ RESULT (NCONC (PERMRADS CENTER RADS NIL)
RESULT)))
(RETURN RESULT)))
EXPR)
(DEFPROP
NUMPARTITIONS*
(LAMBDA
(U MN MAXIMA OCCURLIST)
(IF
(NULL (CDR OCCURLIST))
THEN
(NUMPARTITIONS U (CAR OCCURLIST)
MN
(CAR MAXIMA))
ELSE
(FOR
NEW FIRST :=
((FIX+ (MAX MN
(DIFFERENCE
U
(FOR NEW X IN (CDR MAXIMA)
AS NEW Y IN (CDR OCCURLIST)
PLUS FIRST (TIMES (SUB1 (CAR OCCURLIST))
(CAR MAXIMA))
(TIMES X Y)))))
(MIN (CAR MAXIMA)
(QUOTIENT (DIFFERENCE U (PLUSLIST (CDR OCCURLIST)))
(CAR OCCURLIST))))
FOR NEW REST IN
(IF (EQUAL (CAR OCCURLIST)
1.0)
THEN
(NUMPARTITIONS* (DIFFERENCE U FIRST)
1.0
(CDR MAXIMA)
(CDR OCCURLIST))
ELSE
(NUMPARTITIONS* (DIFFERENCE U FIRST)
FIRST MAXIMA (CONS (SUB1 (CAR OCCURLIST))
(CDR OCCURLIST))))
XLIST
(CONS FIRST REST))))
EXPR)
(DEFPROP
GROUPBY
(LAMBDA
(FN L)
(IF (NULL L)
THEN NIL ELSE
(PROG (FNX GROUPCDR X)
(SETQ GROUPCDR (GROUPBY FN (CDR L)))
(IF (NULL (SETQ X (LMASSOC (SETQ FNX
(FN (CAR L)))
GROUPCDR NIL)))
THEN
(RETURN (CONS (LIST FNX (CAR L))
GROUPCDR))
ELSE
(NCONC X (LIST (CAR L)))
(RETURN GROUPCDR)))))
EXPR)
(DEFPROP
FVPARTITION1
(LAMBDA
(N VL S)
(COND
((NULL VL)
(LIST NIL))
(T (PROG (SUMREST)
(SETQ SUMREST (FOR NEW X IN (CDR VL)
AS NEW SP := ((ADD1 S)
9.999999E6)
PLUS
(TIMES SP X)))
(RETURN (FOR NEW I := ((MAX 0.0 (DIFFERENCE N SUMREST))
(MIN N (TIMES (CAR VL)
S)))
AS NEW PARTREST IS (FVPARTITION1
(DIFFERENCE N I)
(CDR VL)
(ADD1 S))
FOR NEW FIRSTPART IN (FVPART1
I
(CAR VL)
S)
FOR NEW RESTPART IN PARTREST XLIST
(CONS FIRSTPART RESTPART)))))))
EXPR)
(DEFPROP FVPART1
(LAMBDA
(N MAXSUM MAXOCCUR)
(COND
((ZEROP MAXOCCUR)
(LIST NIL))
(T (FOR NEW I := ((MAX 0.0 (DIFFERENCE
N
(TIMES MAXSUM (SUB1 MAXOCCUR))))
(MIN MAXSUM (QUOTIENT N MAXOCCUR)))
FOR NEW REST IN (FVPART1 (DIFFERENCE
N
(TIMES I MAXOCCUR))
(DIFFERENCE MAXSUM I)
(SUB1 MAXOCCUR))
XLIST
(CONS I REST)))))
EXPR)
(DEFPROP MINLOOPS
(LAMBDA
(VALENCELIST)
(MAX 0.0 (PROG (MXV TD)
(SETQ TD (SETQ MXV 0.0))
(FOR NEW X IN (CDR VALENCELIST)
AS NEW VALENCE := (3.0 999999.0)
WHEN
(NOT (ZEROP X))
DO
(IF (GREATERP VALENCE MXV)
THEN
(SETQ MXV VALENCE))
(SETQ TD (PLUS (TIMES X VALENCE)
TD)))
(RETURN (QUOTIENT (DIFFERENCE MXV TD)
2.0)))))
EXPR)
(DEFPROP MAXLOOPS (LAMBDA (VALENCELIST)
(MIN (CAR VALENCELIST)
(FIX+ (FOR NEW W IN (CDDR VALENCELIST)
AS NEW J := (2.0 99999.0)
PLUS
(TIMES .5 W J)))))
EXPR)
STOP